home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / n32lap.t < prev    next >
Text File  |  1988-05-02  |  15KB  |  395 lines
  1. (herald n32lap                                                         ;86/12/19
  2.         (env tsys))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.         
  27. ;;; lap code is of the form (lap free-vars . code)
  28. ;;; lap templates are (lap-template (pointer scratch nargs) . code)
  29.  
  30. (define local-processor                                                ;86/12/19
  31.   (lambda ()
  32.     (object nil
  33.       ((processor-type self)     'NS32000)
  34.       ((print-type-string self)  "Processor"))))
  35.  
  36. (define (template-definer-vcell-offset template)
  37.   (let ((template (if (fixnum-equal? (mref-integer template -2)
  38.                      n32-jump-absolute-hack)
  39.                       (extend-elt template 1)
  40.                       template)))
  41.     (let ((offset (fixnum-ashr (mref-16-u template -12) 3)))
  42.       (if (fx= offset 0) 
  43.           nil
  44.           (fx- offset 1)))))
  45.  
  46. (define (invoke-stack-continuation frame vals)                         ;86/12/19
  47.   (lap (return apply)
  48.     (subi d ($ 2) A1)
  49.     (lpri d SP A1)
  50.     (cmpi d A2 (d@r nil-reg slink/nil-car))
  51.     (j= no-values)
  52.     (cmpi d (d@r A2 -3) (d@r nil-reg slink/nil-car))
  53.     (jn= many-values)
  54.     (movi d (d@r A2 1) A1)
  55.     (movi d ($ -2) NARGS)
  56.     (movi d (@r sp) tp)
  57.     (jump (@r tp))
  58. no-values
  59.     (movi d ($ -1) NARGS)
  60.     (movi d (@r sp) tp)
  61.     (jump (@r tp))
  62. many-values
  63.     (movi d (d@r P (static 'return)) A1)
  64.     (movi d (d@r a1 2) a1)
  65.     (movi d (d@r P (static 'apply)) P)
  66.     (movi d (d@r p 2) p)
  67.     (movi d ($ 3) NARGS)
  68.     (movi d (d@r p -2) tp)
  69.     (jump (@r tp))))
  70.  
  71. (define (invoke-continuation sp stack vals base-state current-state)   ;86/12/20
  72.   (lap (rewind-state-and-continue)
  73.     (ori b ($ #b01000000) (d@r TASK (fx+ task/critical-count 3)))  ; ignore int's
  74.     (lpri d SP A1)                    ; set new continuation
  75.     (movi d (d@r TASK task/stack) S0) ; limit at stack base
  76.     (addi d ($ 2) A2)                 ; start at first word of stack in heap
  77.     (jbr copy-stack-test)
  78. copy-stack-loop 
  79.     (movi d (@r A2) (@r A1))
  80.     (addi d ($ 4) a2)                 ; can save an instruction with index mode
  81.     (addi d ($ 4) a1)
  82. copy-stack-test
  83.     (cmpi d S0 A1)
  84.     (j>= copy-stack-loop)
  85.     (bici b ($ #b1000000) (d@r TASK (fx+ task/critical-count 3)))
  86.     (movi d (d@r TASK 12) A1) 
  87.     (movi d (d@r TASK 16) A2)
  88.     (movi d (d@r P (static 'rewind-state-and-continue)) P)
  89.     (movi d (d@r p 2) p)
  90.     (movi d ($ 4) NARGS)
  91.     (movi d (d@r p -2) tp)
  92.     (jump (@r tp))))
  93.  
  94.  
  95. ;;; (FIXNUM-HOWLONG n)
  96. ;;;   Returns the number of bits in N's binary representation.
  97. ;;;   Horrible name, after MACLISP function HAULONG.
  98. ;;;   Similar to a binary search.  Repeatedly divide the bit string in half.
  99. ;;;     If the upper half has any bits on, count all the bits in the lower
  100. ;;;     half and throw them away.
  101.  
  102. (define (fixnum-howlong num)                                           ;86/12/20
  103.   (lap ()
  104.     (cmpi d A1 ($ 0))
  105.     (j>= howlong0)
  106.     (movi d ($ (fx* 30 4)) A1)    ; negative fixnum, length is 30.
  107.     (jbr howlong_exit)
  108. howlong0
  109.     (movi d A1 S0)
  110.     (lshi d ($ -2) S0)            ; S0 holds number
  111.     (movi d ($ 0) A1)             ; A1 holds result
  112.     (cmpi d S0 ($ #x8000))
  113.     (j< howlong1)
  114.     (addi d ($ (fx* 16 4)) A1)    ; add 16 to result
  115.     (ashi d ($ -16) S0)
  116. howlong1
  117.     (cmpi d S0 ($ #x80))
  118.     (j< howlong2)
  119.     (addi d ($ (fx* 8 4)) A1)
  120.     (ashi d ($ -8) S0)
  121. howlong2
  122.     (cmpi d S0 ($ #x8))
  123.     (j< howlong3)
  124.     (addi d ($ (fx* 4 4)) A1)
  125.     (ashi d ($ -4) S0)
  126. howlong3
  127.     (cmpi d S0 ($ #x2))
  128.     (j< howlong4)
  129.     (addi d ($ (fx* 2 4)) A1)
  130.     (ashi d ($ -2) S0)
  131. howlong4
  132.     (cmpi d S0 ($ #x1))
  133.     (j< howlong_exit)
  134.     (addi d ($ (fx* 1 4)) A1)
  135. howlong_exit
  136.     (movi d ($ -2) NARGS)
  137.     (movi d (@r sp) tp)
  138.     (jump (@r tp))))
  139.  
  140.  
  141. (define (*set x y)                                                     ;86/12/20
  142.   (lap ()  
  143.     (movi d A2 (d@r a1 2))
  144.     (cmpi b ($ 0) (@r a1))
  145.     (j= foo-set)
  146.     (movi d a1 (d@r TASK task/extra-pointer))
  147.     (jsr (*d@r nil-reg slink/set))
  148. foo-set
  149.     (movi d ($ -2) NARGS)
  150.     (movi d (@r sp) tp)
  151.     (jump (@r tp))))
  152.  
  153. (define (apply-traced-operation proc . args)                           ;86/12/20
  154.   (lap (*traced-op-template*)
  155.     (movi d (d@r P (static '*traced-op-template*)) TP)
  156.     (movi d (d@r tp 2) tp)
  157.     (movi d ($ 0) (d@r TASK task/extra-scratch))
  158.     (jbr entry)))
  159.  
  160.  
  161. ;;; Remember that APPLY is nary; only the last argument must be a list.
  162. ;;; ALG:  
  163. ;;;    - Move all arguments down one register (e.g. A2 must move to A1).
  164. ;;;      This requires special case code for A1, A2, A3, then a loop for 
  165. ;;;      the argument registers in the task block.
  166. ;;;    - The last argument is actually a list of the remaining arguments; move 
  167. ;;;      the elements to argument registers.
  168. ;;;    - Call the procedure.
  169.  
  170. (define (apply proc . args)                                            ;86/12/20
  171.   (lap (apply-too-many-args)
  172.     (movi d ($ 1) (d@r TASK task/extra-scratch))
  173. entry
  174.     (subi d ($ 1) NARGS)                   ;; shift proc out
  175.     (movi d P (tos))                         ;; save environment 
  176.     (movi d A1 (tos))                        ;; first arg is proc (save it)
  177.     (cmpi d ($ 1) NARGS)                   ;; no args to proc
  178.     (j= apply-done)
  179.     (subi d ($ 1) NARGS)
  180.     (cmpi d ($ 1) NARGS)
  181.     (jn= next1)
  182.     (movi d A2 AN)
  183.     (jbr apply-one-arg)
  184. next1
  185.     (cmpi d ($ 2) NARGS)
  186.     (jn= next2)
  187.     (movi d A2 A1)
  188.     (movi d A3 AN)
  189.     (jbr apply-two-args)
  190. next2
  191.     (cmpi d ($ 3) NARGS)
  192.     (jn= next3)
  193.     (movi d A2 A1)
  194.     (movi d A3 A2)
  195.     (movi d (d@r TASK 12) AN)            ;; first argument temp
  196.     (jbr apply-three-args)
  197. next3
  198.     (movi d A2 A1)
  199.     (movi d A3 A2)
  200.     (movi d (d@r TASK 12) A3)            ;; first argument temp
  201.     (movi d NARGS S0)
  202.     (subi d ($ 4) S0)                    ;; S0 counts down to 0
  203.     (addr (d@r TASK 16) P)             ;; set up P to point into rest vector
  204.                                        ;; first 3 temps reserved, 1 done already
  205.     (jbr apply-shift-test)
  206. apply-shift-loop-top
  207.     (movi d (@r P) (d@r P -4))
  208.     (subi d ($ 1) S0)
  209.     (addi d ($ 4) P)
  210. apply-shift-test
  211.     (cmpi d ($ 0) S0)
  212.     (jn= apply-shift-loop-top)
  213.     (movi d (@r P) AN)  
  214.     (subi d ($ 4) P)
  215.     (jbr apply-spread-loop)
  216. apply-one-arg
  217.     (cmpi d AN (d@r nil-reg slink/nil-car)) 
  218.     (j= apply-done)
  219.     (movi d (d@r AN 1) A1)                    
  220.     (addi d ($ 1) NARGS)
  221.     (movi d (d@r AN -3) AN)                   
  222. apply-two-args
  223.     (cmpi d AN (d@r nil-reg slink/nil-car))   
  224.     (j= apply-done)
  225.     (movi d (d@r AN 1) A2)                    
  226.     (addi d ($ 1) NARGS)
  227.     (movi d (d@r AN -3) AN)                   
  228. apply-three-args
  229.     (cmpi d AN (d@r nil-reg slink/nil-car))   
  230.     (j= apply-done)
  231.     (movi d (d@r AN 1) A3)                    
  232.     (addi d ($ 1) NARGS)
  233.     (movi d (d@r AN -3) AN)                   
  234.     (addr (d@r TASK 12) P)
  235. apply-spread-loop              
  236.     (cmpi d AN (d@r nil-reg slink/nil-car))
  237.     (j= apply-done)
  238.     (movi d (d@r AN 1) (@r P))
  239.     (addi d ($ 1) NARGS)
  240.     (cmpi d NARGS ($ (+ *pointer-temps* 1)))
  241.     (j> too-many)
  242.     (addi d ($ 4) P)
  243.     (movi d (d@r AN -3) AN)
  244.     (jbr apply-spread-loop)
  245. too-many
  246.     (movi d (tos) A1)                             ; procedure is argument
  247.     (movi d (tos) P)
  248.     (movi d ($ 2) NARGS)
  249.     (movi d (d@r P (static 'apply-too-many-args)) P)
  250.     (movi d (d@r p 2) p)
  251.     (movi d (d@r p -2) tp)
  252.     (jump (@r tp))
  253. apply-done                                
  254.     (movi d (tos) P)                              ; restore procedure
  255.     (adjspi b ($ -4))                             ; get rid of environment
  256.     (cmpi d ($ 0) (d@r TASK task/extra-scratch))
  257.     (j= traced)
  258.     (movi d (d@r p -2) tp)
  259.     (jump (@r tp))
  260. traced            
  261.     (jump (@r TP))))
  262.  
  263. ;;; n32 code uses only 2 scratch registers (S0 and NARGS)
  264.  
  265. (define (string-hash string)                                           ;86/12/20
  266.   ;; string in A1
  267.   (lap ()
  268.     ;; enter critical gc
  269.     (movi d (d@r A1 offset/string-text) A3);; raw string text in A3
  270.     (addi d (d@r A1 offset/string-base) A3)                              
  271.     (addi d ($ 2) A3)
  272. hash                
  273.     (movi d (d@r A1 -2) S0)                   ;; string length in S0, will count
  274.     (ashi d ($ -8) S0)                        ;;   down to 0
  275.     (movi d ($ 0) NARGS)                      ;; hash value so far in NARGS
  276.     (jump (label hash-test))
  277. hash-loop
  278.     (roti d ($ 1) NARGS)                      ;++ change to 3 later
  279.     (addi b (@r A3) NARGS)
  280.     (addi d ($ 1) A3)
  281. hash-test
  282.     (subi d ($ 1) S0)
  283.     (cmpi d S0 ($ 0))  
  284.     (j>= hash-loop)                         ;; loop if count >= 0
  285.         ;; exit critical gc
  286.     (movi d NARGS S0)                         ;; re-use S0 as temp
  287.     (roti d ($ 16) S0) 
  288.     (xori d S0 NARGS) 
  289.     (bici d ($ #x80000003) NARGS)             ;; positive-fixnumize
  290.     (movi d NARGS A1)
  291.     (movi d ($ -2) NARGS)                     ;; NARGS back to standard usage
  292.     (movi d (@r sp) tp)
  293.     (jump (@r tp))))
  294.  
  295. ;;;  magic frame is next-state
  296. ;;;                 winder
  297. ;;;                 previous-state
  298. ;;;                 unwinder
  299. ;;;                 *magic-frame-template*
  300.  
  301. (define (push-magic-frame unwinder stuff wind)                         ;86/12/20
  302.   (lap (*magic-frame-template* bind-internal)
  303.     (movi d (d@r TASK task/dynamic-state) AN)
  304.     (spri d nil-reg (tos))                      ; next state
  305.     (movi d A3 (tos))                           ; winder
  306.     (movi d AN (tos))                           ; previous state
  307.     (movi d A1 (tos))                           ; unwinder
  308.     (movi d (d@r P (static '*magic-frame-template*)) a3)
  309.     (movi d (d@r a3 2) (tos))
  310.     (addr (d@r SP 2) A1)                        ; first arg is the magic frame
  311.     (cmpi d AN (d@r nil-reg slink/nil-car))     ; is there a previous state?
  312.     (j= magic-frame-exit)
  313.     (movi d A1 (d@r AN 14))                     ; set next slot to this magic frame
  314. magic-frame-exit
  315.     (movi d (d@r P (static 'bind-internal)) P)  ; second arg is stuff
  316.     (movi d (d@r p 2) p)
  317.     (movi d ($ 3) NARGS)
  318.     (movi d (d@r p -2) tp)
  319.     (jump (@r tp))))
  320.  
  321.  
  322. (define (make-structure-template size)                                 ;86/12/20
  323.   (lap (*structure-template* *stype-template*)
  324.     (movi d (d@r P (static '*stype-template*)) AN)
  325.     (movi d (d@r an 2) an)
  326.     (movi d ($ 40) S0)                             ; 10 slots
  327.     (jsr (*d@r nil-reg slink/make-extend))
  328.     (movi w ($ 32) (d@r AN 26))                    ; offset within closure
  329.     (movi b ($ 0) (d@r AN 28))                     ; 0 scratch slots
  330.     (movi d A1 S0)
  331.     (ashi d ($ -2) S0)                             ; pointer slots
  332.     (movi b S0 (d@r AN 29))               
  333.     (movi w ($ header/template) (d@r AN 30))
  334.     (movi w ($ N32-JUMP-ABSOLUTE) (d@r AN 32))
  335.     (movi d ($ slink/cit-hack) (d@r AN 34))
  336.     (movi d (d@r P (static '*structure-template*)) p)
  337.     (movi d (d@r p 2) (d@r AN 38)) ; auxilliary template
  338.     (addr (d@r AN 32) A1)                          ; return template
  339.     (movi d AN A2)                                 ; and stype
  340.     (movi d ($ -3) NARGS)                          ; return two values
  341.     (movi d (@r sp) tp)
  342.     (jump (@r tp))))
  343.  
  344.  
  345. ;;; Floating point bit fields.
  346.  
  347. ;;; <n,s> means bit field of length s beginning at bit n of the first
  348. ;;; WORD (not longword)
  349. ;;;                    sign      exponent   MSB       fraction
  350. ;;; Apollo IEEE flonum <15,1>    <4,11>     hidden    <0,4>+next 3 words
  351. ;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words
  352. ;;; Apollo IEEE flonum - binary point follows  hidden MSB, 53 bits of
  353. ;;;     precision, if hidden bit is included
  354. ;;; VAX11 flonum (D)   - binary point precedes hidden MSB, 56 bits of
  355. ;;;     precision, if hidden bit is included 
  356.  
  357. (define-constant %%d-ieee-size 53)
  358. (define-constant %%d-ieee-excess 1023)
  359.  
  360. ;;; <n,s> means bit field of length s beginning at bit n of the first
  361. ;;; WORD (not longword)
  362. ;;;                    sign      exponent   MSB       fraction
  363. ;;; IEEE flonum        <15,1>    <4,11>     hidden    <0,4>+next 3 words
  364. ;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words
  365.  
  366. (define (integer-decode-float x)     ; IEEE version
  367.   (let ((a (mref-16-u x 6)))
  368.     (return (if (fl<= 0.0 x) 1 -1)
  369.             (+ (mref-16-u x 0)
  370.                (%ash (+ (mref-16-u x 2)
  371.                         (%ash (fx+ (mref-16-u x 4)
  372.                                    (fixnum-ashl (fx+ (fixnum-bit-field a 0 4)
  373.                              16)
  374.                                                 16))
  375.                               16))
  376.                      16))
  377.             (fx- (fixnum-bit-field a 4 11) (fx+ 1024 51)))))
  378.  
  379. (define (integer-encode-float sign m e)
  380.   (let ((float (make-flonum)))
  381.     (receive (sign mantissa exponent)
  382.              (normalize-float-parts sign
  383.                                     m
  384.                                     e
  385.                                     %%d-ieee-size 
  386.                                     %%d-ieee-excess 
  387.                                     t)
  388.       (set (mref-16-u float 6) (fx+ (fixnum-ashl sign 15)
  389.                                     (fx+ (fixnum-ashl exponent 4)
  390.                                          (bignum-bit-field mantissa 48 4))))
  391.       (set (mref-16-u float 4) (bignum-bit-field mantissa 32 16)) 
  392.       (set (mref-16-u float 2) (bignum-bit-field mantissa 16 16)) 
  393.       (set (mref-16-u float 0) (bignum-bit-field mantissa 0  16)) 
  394.       float)))
  395.